home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 5 / Skunkware 5.iso / lib / emacs / 19.22 / lisp / pp.el < prev    next >
Lisp/Scheme  |  1993-10-10  |  6KB  |  172 lines
  1. ;; pp.el --- pretty printer for Emacs Lisp
  2. ;; Copyright (C) 1989, 1993 Free Software Foundation, Inc.
  3.  
  4. ;; Author: Randal Schwartz <merlyn@ora.com>
  5.  
  6. ;; This file is part of GNU Emacs.
  7.  
  8. ;; GNU Emacs is free software; you can redistribute it and/or modify
  9. ;; it under the terms of the GNU General Public License as published by
  10. ;; the Free Software Foundation; either version 2, or (at your option)
  11. ;; any later version.
  12.  
  13. ;; GNU Emacs is distributed in the hope that it will be useful,
  14. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16. ;; GNU General Public License for more details.
  17.  
  18. ;; You should have received a copy of the GNU General Public License
  19. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  20. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  21.  
  22. ;;; Code:
  23.  
  24. (defvar pp-escape-newlines t 
  25.   "*Value of print-escape-newlines used by pp-* functions.")
  26.  
  27. (defun pp-to-string (object)
  28.   "Return a string containing the pretty-printed representation of OBJECT,
  29. any Lisp object.  Quoting characters are used when needed to make output
  30. that `read' can handle, whenever this is possible."
  31.   (save-excursion
  32.     (set-buffer (generate-new-buffer " pp-to-string"))
  33.     (unwind-protect
  34.     (progn
  35.       (emacs-lisp-mode)
  36.       (let ((print-escape-newlines pp-escape-newlines))
  37.         (prin1 object (current-buffer)))
  38.       (goto-char (point-min))
  39.       (while (not (eobp))
  40.         ;; (message "%06d" (- (point-max) (point)))
  41.         (cond
  42.          ((looking-at "\\s\(")
  43.           (while (looking-at "\\s(")
  44.         (forward-char 1)))
  45.          ((and (looking-at "\\(quote[ \t]+\\)\\([^.)]\\)")
  46.            (> (match-beginning 1) 1)
  47.            (= ?\( (char-after (1- (match-beginning 1))))
  48.            ;; Make sure this is a two-element list.
  49.            (save-excursion
  50.              (goto-char (match-beginning 2))
  51.              (forward-sexp)
  52.              ;; (looking-at "[ \t]*\)")
  53.              ;; Avoid mucking with match-data; does this test work?
  54.              (char-equal ?\) (char-after (point)))))
  55.           ;; -1 gets the paren preceding the quote as well.
  56.           (delete-region (1- (match-beginning 1)) (match-end 1))
  57.           (insert "'")
  58.           (forward-sexp 1)
  59.           (if (looking-at "[ \t]*\)")
  60.           (delete-region (match-beginning 0) (match-end 0))
  61.         (error "Malformed quote"))
  62.           (backward-sexp 1))          
  63.          ((condition-case err-var
  64.           (prog1 t (down-list 1))
  65.         (error nil))
  66.           (backward-char 1)
  67.           (skip-chars-backward " \t")
  68.           (delete-region
  69.            (point)
  70.            (progn (skip-chars-forward " \t") (point)))
  71.           (if (not (char-equal ?' (char-after (1- (point)))))
  72.           (insert ?\n)))
  73.          ((condition-case err-var
  74.           (prog1 t (up-list 1))
  75.         (error nil))
  76.           (while (looking-at "\\s)")
  77.         (forward-char 1))
  78.           (skip-chars-backward " \t")
  79.           (delete-region
  80.            (point)
  81.            (progn (skip-chars-forward " \t") (point)))
  82.           (if (not (char-equal ?' (char-after (1- (point)))))
  83.           (insert ?\n)))
  84.          (t (goto-char (point-max)))))
  85.       (goto-char (point-min))
  86.       (indent-sexp)
  87.       (buffer-string))
  88.       (kill-buffer (current-buffer)))))
  89.  
  90. (defun pp (object &optional stream)
  91.   "Output the pretty-printed representation of OBJECT, any Lisp object.
  92. Quoting characters are printed when needed to make output that `read'
  93. can handle, whenever this is possible.
  94. Output stream is STREAM, or value of `standard-output' (which see)."
  95.   (princ (pp-to-string object) (or stream standard-output)))
  96.  
  97. (defun pp-eval-expression (expression)
  98.   "Evaluate EXPRESSION and pretty-print value into a new display buffer.
  99. If the pretty-printed value fits on one line, the message line is used
  100. instead.  Value is also consed on to front of variable  values 's
  101. value."
  102.   (interactive "xPp-eval: ")
  103.   (setq values (cons (eval expression) values))
  104.   (let* ((old-show-hook
  105.       (or (let ((sym (if (> (string-to-int emacs-version) 18)
  106.                  'temp-buffer-show-function
  107.                'temp-buffer-show-hook)))
  108.         (and (boundp 'sym) (symbol-value sym)))
  109.           'display-buffer))
  110.      (temp-buffer-show-hook
  111.       (function
  112.        (lambda (buf)
  113.          (save-excursion
  114.            (set-buffer buf)
  115.            (goto-char (point-min))
  116.            (end-of-line 1)
  117.            (if (or (< (1+ (point)) (point-max))
  118.                (>= (- (point) (point-min)) (screen-width)))
  119.            (progn
  120.              (goto-char (point-min)) ; expected by some hooks ...
  121.              (funcall old-show-hook buf))
  122.          (message "%s" (buffer-substring (point-min) (point)))
  123.          (delete-windows-on buf) ; no need to kill it
  124.          )))))
  125.      (temp-buffer-show-function temp-buffer-show-hook)) ; emacs19 name
  126.     (with-output-to-temp-buffer "*Pp Eval Output*"
  127.       (pp (car values)))
  128.     (save-excursion
  129.       (set-buffer "*Pp Eval Output*")
  130.       (emacs-lisp-mode))))
  131.  
  132. (defun pp-eval-last-sexp (arg)
  133.   "Run `pp-eval-expression' on sexp before point (which see).
  134. With argument, pretty-print output into current buffer.
  135. Ignores leading comment characters."
  136.   (interactive "P")
  137.   (let ((stab (syntax-table)) (pt (point)) start exp)
  138.     (set-syntax-table emacs-lisp-mode-syntax-table)
  139.     (save-excursion
  140.       (forward-sexp -1)
  141.       ;; If first line is commented, ignore all leading comments:
  142.       (if (save-excursion (beginning-of-line) (looking-at "[ \t]*;"))
  143.       (progn
  144.         (setq exp (buffer-substring (point) pt))
  145.         (while (string-match "\n[ \t]*;+" exp start)
  146.           (setq start (1+ (match-beginning 0))
  147.             exp (concat (substring exp 0 start)
  148.                 (substring exp (match-end 0)))))
  149.         (setq exp (read exp)))
  150.     (setq exp (read (current-buffer)))))
  151.     (set-syntax-table stab)
  152.     (if arg
  153.     (insert (pp-to-string (eval exp)))
  154.       (pp-eval-expression exp))))
  155.  
  156. ;;; Test cases for quote
  157. ;; (pp-eval-expression ''(quote quote))
  158. ;; (pp-eval-expression ''((quote a) (quote b)))
  159. ;; (pp-eval-expression ''('a 'b))    ; same as above
  160. ;; (pp-eval-expression ''((quote (quote quote)) (quote quote)))
  161. ;; These do not satisfy the quote test.
  162. ;; (pp-eval-expression ''quote)
  163. ;; (pp-eval-expression ''(quote))
  164. ;; (pp-eval-expression ''(quote . quote))
  165. ;; (pp-eval-expression ''(quote a b))
  166. ;; (pp-eval-expression ''(quotefoo))
  167. ;; (pp-eval-expression ''(a b))
  168.  
  169. (provide 'pp)                ; so (require 'pp) works
  170.  
  171. ;;; pp.el ends here.
  172.